perm filename WRTPAG.F4[MSS,LCS]5 blob
sn#269277 filedate 1977-03-11 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE WRTPAG
C00016 ENDMK
C⊗;
SUBROUTINE WRTPAG
DATA SLSP/12.0/
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
1 /SF/KL,RT,KP,STFSZ,NAMX,EXT /IPG/IPG
1 ,JPG,BRACK(-3/4),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
1 /RSP/KNM(10),ENDLN,N,NAME,NMPG,T /KBAR/KBAR(512)
1 /RCLF/KK,CL,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,ITR
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
DIMENSION ENDSTF(450),KPTR(50)
C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R7,RQ(5))
1,(R8,RQ(6)),(LCNT,IV(45)),(NDPY,IV(46)),(ENDSTF,KBAR(4))
NPG=1
NMPG='PAGEA'
HORZ=96.
RNUM=0.
LB=0
ITR=LL
C TRANSPOSE IS IN LL
RA=0
JEND=-1
METR=1000
CLEF=-99
JSLUR=0
LC=1
KREAD=128
SIG=CLEF
HX=2
KQ=1
KPX=1
CALL FILOUT
C NAMQ AND NPG ARE SET IN FILOUT
SP=2.45
C DEFAULT VERT. SPACE UNITS
ENDSTF(1)=0
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
SP=SP+(HX-2.)*.11
100 CALL FILEIN
320 CALL STAVES
CC IF(IPG)GO TO 3000
IF(NPG.NE.1)GO TO 3000
RT=RSTNUM(JPG)
RS=100.+HORZ
HORZ=-HORZ
RNUM=RNUM+1
C ADDS PAGE NUMBER.
CALL STAFF(4.,10.,RS,28.,RNUM,1.1,0,0,0,0,0,0)
3000 IF(ITR.NE.0)CALL TRNSP
JPQ=KL
NA=0
KPT=1
ENDSTF(1)=0
C LOOP STARTS HERE *******
131 NA=NA+1
KWDS(KP)=JPQ
KP=KP+1
R=CODEN(KPN,NA,Q,JK)
RR=Q(JK+6)
RS=Q(JK)
IF(R.NE.5)GO TO 935
R8=-1
IF(RS.GE.6)R8=Q(JK+8)
IF(RR)GO TO 735
IF(RR.LE.Q(JK+3))RR=202.
GO TO 235
C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
935 IF(R.EQ.7)GO TO 835
IF(R.NE.44)GO TO 35
R=R/11.
Q(JK+1)=R
C INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
IF(RR.LT.Q(JK+3))GO TO 30
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
835 R8=0
R7=0
IF(RS.GE.6)R8=Q(JK+8)
235 IF(RR.LT.199.)GO TO 30
C P1,P2,P3,P4,P5,P6,P7,P8 ARE SAVED.
RR=-1
735 IF(RS.GE.5)R7=Q(JK+7)
ENDSTF(KPT)=6
ENDSTF(KPT+1)=R
C=Q(JK+2)
ENDSTF(KPT+2)=C
ENDSTF(KPT+3)=1
ENDSTF(KPT+4)=Q(JK+4)
ENDSTF(KPT+5)=Q(JK+5)
ENDSTF(KPT+7)=R7
ENDSTF(KPT+8)=R8
ENDSTF(KPT+6)=RR
CX A=Q(JK+6)
CX B=0
CX R7=0
CX DO 136 K=NA+1,NPX
C THIS LOOP GETS NOTE POS. OF RIGHT SIDE OF SLUR.
CX KK=KPN(K)
CX R=Q(KK+1)
CX IF(R.NE.1)GO TO 136
CX IF(C.NE.Q(KK+2))GO TO 136
CX B=B+1
CX R8=Q(KK+3)
C FIND NOTE BEFORE AND AFTER RIGHT END OF SLUR
CX IF(R8.LE.A)GO TO 336
CX ENDSTF(KPT+6)=-B+(R8-A)/(R8-R7)
C SAVE NEG. NOTE COUNT. POSITIVE WILL ALWAYS BE 12.
CX GO TO 236
CX336 R7=R8
C FIND POS OF NOTE JUST BEFORE POINT.
CX136 CONTINUE
236 KPT=KPT+13
ENDSTF(KPT)=0
Q(JK+6)=202
GO TO 30
C*************
35 IF(R.NE.2)GO TO 36
IF(RS.LT.6.)GO TO 30
CC R=Q(JK+2)
C THE STAFF NUM.
CC DO 134 K=NA-1,1,-1
CC R8=CODEN(KPN,K,Q,LL)
CC IF(R8.EQ.4)GO TO 234
CC IF(Q(LL+2).NE.R)GO TO 134
CC IF(R8.LT.10)GO TO 234
CC134 CONTINUE
C NOW FOUND ITEM TO LEFT ON THIS STAFF.
CC234 RR=Q(LL+3)
CC DO 334 K=NA+1,I
CC R8=CODEN(KPN,K,Q,LL)
CC IF(R8.EQ.4)GO TO 434
CC IF(Q(LL+2).NE.R)GO TO 334
CC IF(R8.LT.10)GO TO 434
CC334 CONTINUE
CC434 RS=Q(LL+3)
C NOW FOUND ITEM TO RIGHT ON THIS STAFF.
RR=RIGHT(NA,-1,JK)
CR IF(RR.GE.199.)RR=RX
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1,JK)-RR)/2.
C FUNCTION 'RIGHT' FINDS ITEMS TO LFT AND RT OF REST FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
CLEF=CLEFN(Q,JK)
CPT IF(IPG)GO TO 30
LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
RCLEF(LL)=CLEF
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GT.100.)SIG=-99
C DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 130
38 Q(JK+1)=R/11.
GO TO 30
130 IF(Q(JK+3).LT.199)GO TO 30
IF(R.NE.18)GO TO 30
KKK=K+1
R3=9
IF(SIG.NE.-99)R3=14
KK=JK
CC435 R8=0
CC R9=0
CC R10=0
435 LL=KPN(KKK)
C WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
ENDSTF(KPT)=Q(KK)
ENDSTF(KPT+1)=R
ENDSTF(KPT+2)=Q(KK+2)
ENDSTF(KPT+3)=R3
CC ENDSTF(KPT+4)=Q(KK+4)
CC ENDSTF(KPT+5)=Q(KK+5)
CC ENDSTF(KPT+6)=Q(KK+6)
CC ENDSTF(KPT+7)=0
CC ENDSTF(KPT+8)=0
DO 535 JJ2=4,12
535 ENDSTF(KPT+JJ2)=Q(KK+JJ2)
KPT=KPT+13
ENDSTF(KPT)=0
RS=Q(LL+1)
IF(RS.LE.4)GO TO 30
R4=Q(LL+2)
C SAVE THE STAFF NUM. IN R4
IF(RS.NE.18)GO TO 7011
335 R3=R3+6
KK=LL
KKK=KKK+1
GO TO 435
7011 RS=CODEN(KPN,KKK+1,Q,LL)
IF(RS.LE.4)GO TO 30
IF(Q(LL+2).NE.R4)GO TO 30
IF(RS.EQ.18)GO TO 335
30 JPQ=KPN(NA+1)-KPN(NA)+JPQ
IF(NA.LT.I)GO TO 131
C END OF LOOP ****************
CALL PSHFT(I)
RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-1
CALL PTMOVE(RN,KWDS(1))
C START LAST LOOP *******
DO 47 JJ2=1,KP
LL=KWDS(JJ2)
AA=RN(LL+1)
IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
CN IF(AA.NE.10.AND.AA.NE.16)GO TO 347
DO 147 NN=JJ2+1,KP
MM=KWDS(NN)
IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
IF(RN(MM+3).LT.AA)RN(MM+3)=AA
GO TO 47
247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
AA=RN(LL+4)+7
IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
GO TO 47
147 CONTINUE
GO TO 47
CN347 IF(AA.NE.5)GO TO 1047
C TO IMPROVE SLUR PARAMETERS
CN R8=RN(LL+8)
CN IF(RN(LL).LT.6)R8=0
CN IF(R8.GT.0)GO TO 47
C JUMP IF A BRACKET
CN R=RN(LL+6)
CN DO 647 NN=JJ2+1,KP
CN MM=KWDS(NN)
C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
CN IF(RN(MM+1).NE.4)GO TO 647
C FIND A BAR LINE
CN IF(RN(MM+3).GT.199.)GO TO 647
C IGNORE LAST BAR OR LINE.
CN IF(RN(MM).GT.2)GO TO 647
CN AA=ABS(RN(MM+3)-R)
CN IF(AA.GT.1.)GO TO 647
CN RN(LL+6)=R+4
CN GO TO 47
CN647 CONTINUE
CN R7=RN(LL+7)
CN R9=R-RN(LL+3)+(R8+1.)*2.
CN IF(R9.GT.7)GO TO 47
C NO WORK NEEDED. IT'S LONG ENOUGH
CN IF(RN(LL).GT.5)RN(LL+8)=-1
CN R=1.
CN IF(R7.LT.0)R=-R
CN547 RN(LL+4)=RN(LL+4)+R
CN RN(LL+5)=RN(LL+5)+R
C WERE +AA ↑↑↑↑↑
CN RN(LL+7)=R
CN GO TO 47
1047 IF(AA.NE.6)GO TO 47
IF(RN(LL).LT.7)GO TO 47
IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
47 CONTINUE
2 KWDS(KP)=JPQ
CP J=1
IF(KP.GE.250.OR.JPQ.GE.2000)TYPE 20,KP,JPQ
JJ2=KP+1
C WRITES 1 EXTRA WORD
CP JPQ=KB
DO 12 K=1,KP
CC N=KWDS(K)
CC R=RN(N+1)
R=CODEN(KWDS,K,RN,N)
IF(R.LE.2)GO TO 22
C ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
IF(R.GT.7)GO TO 12
IF(R.EQ.5)GO TO 52
IF(R.NE.4)GO TO 62
IF(RN(N).GE.4)GO TO 52
62 IF(R.NE.7)GO TO 12
52 A=RN(N+6)
C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
IF(A.GE.0)GO TO 12
J=A
IF(J.EQ.0)J=-1
B=RN(N+2)
C B=STAFF NUM.
JJ=0
DO 32 KK=K+1,KP
CC NN=KWDS(KK)
CC A=RN(NN+1)
A=CODEN(KWDS,KK,RN,NN)
IF(A.NE.1)GO TO 32
IF(B.NE.RN(NN+2))GO TO 32
D=RN(NN+3)
JJ=JJ-1
IF(J.NE.JJ)GO TO 42
RN(N+6)=D+(D-A)*(RN(N+6)-J)
C FOUND NOTE FOR POSITION.
GO TO 12
42 A=D
32 CONTINUE
12 CONTINUE
22 CALL PUTEXT(NAMX,EXT)
LCNT=0
NDPY=0
RSTFAC(96)=0
C MUST BE 0 IN MS TO MAKE DISPLAY
CALL EXTOUT(RSTFAC,128)
CALL EXTOUT(KWDS,JJ2)
CALL EXTOUT(RN,JPQ)
TYPE 101,NAMX,EXT
NAMX=NAMX+2
CC IF(IPG)GO TO 6011
NPG=NPG+1
IF(NPG.LE.MPG)GO TO 6011
NPG=1
C RESET, UPDATE FILENAMES
NAMX=NAMZ+256
NAMZ=NAMX
6011 NAMQ=NAMX
CALL FINEXT
GO TO 100
C IPG=1 = GO BACK TO TRONLY INSTEAD
101 FORMAT(1XA5,'.',A3)
20 FORMAT(' TOO MUCH DATA!!! ',I3,'/250',I5,'/2000')
END
CC SUBROUTINE NAMEXT
CC COMMON /SF/KL,RT,KP,STFSZ,NAME,EXT
CC COMMON RS,JA,CLEFQ,AA,RQ(6),I(10),KQ,NQ,JQ,JJQ,KBQ,NAQ
CC11 TYPE 12
CC ACCEPT 1,I
CC DO 2 K=2,6
CC IF(I(K).EQ.' ')GO TO 3
CC2 IF(I(K).EQ.'.')GO TO 4
CC TYPE 10
CC GO TO 11
CC10 FORMAT(' 5 LTR NAME + EXT ONLY'/)
CC12 FORMAT(' TYPE FILE NAME -- '$)
CC3 REREAD 99,NAME
CC RETURN
CC4 GO TO(1,5,6,7,8,9),K
CC1 FORMAT(10A1)
CC55 FORMAT(2A1,A3)
CC66 FORMAT(A2,A1,A3)
CC77 FORMAT(A3,A1,A3)
CC88 FORMAT(A4,A1,A3)
CC99 FORMAT(A5,A1,A3)
CC5 REREAD 55,NAME,K,EXT
CC RETURN
CC6 REREAD 66,NAME,K,EXT
CC RETURN
CC7 REREAD 77,NAME,K,EXT
CC RETURN
CC8 REREAD 88,NAME,K,EXT
CC RETURN
CC9 REREAD 99,NAME,K,EXT
CC END